home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / error.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  33.1 KB  |  959 lines
  1. ;;; -*- Package: conditions; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: error.lisp,v 1.18 92/07/10 17:48:23 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This is a condition system for CMU Common Lisp.
  15. ;;; It was originally taken from some prototyping code written by KMP@Symbolics
  16. ;;; and massaged for our uses.
  17. ;;;
  18.  
  19. (in-package "CONDITIONS")
  20. (use-package "EXTENSIONS")
  21.  
  22. (in-package "LISP")
  23. (export '(break error warn cerror
  24.       ;;
  25.       ;; The following are found in Macros.Lisp:
  26.       check-type assert etypecase ctypecase ecase ccase
  27.       ;;
  28.       ;; These are all the new things to export from "LISP" now that this
  29.       ;; proposal has been accepted.
  30.       *break-on-signals* *debugger-hook* signal handler-case handler-bind
  31.       ignore-errors define-condition make-condition with-simple-restart
  32.       restart-case restart-bind restart-name restart-name find-restart
  33.       compute-restarts invoke-restart invoke-restart-interactively abort
  34.       continue muffle-warning store-value use-value invoke-debugger restart
  35.       condition warning serious-condition simple-condition simple-warning
  36.       simple-error simple-condition-format-string
  37.       simple-condition-format-arguments storage-condition stack-overflow
  38.       storage-exhausted type-error type-error-datum
  39.       type-error-expected-type simple-type-error program-error
  40.       control-error stream-error stream-error-stream end-of-file file-error
  41.       file-error-pathname cell-error unbound-variable undefined-function
  42.       arithmetic-error arithmetic-error-operation arithmetic-error-operands
  43.       package-error package-error-package division-by-zero
  44.       floating-point-overflow floating-point-underflow))
  45.  
  46. (in-package "EXTENSIONS")
  47. (export '(floating-point-inexact floating-point-invalid))
  48.  
  49. (in-package "CONDITIONS")
  50.  
  51. ;;;; Keyword utilities.
  52.  
  53. (eval-when (eval compile load)
  54.  
  55. (defun parse-keyword-pairs (list keys)
  56.   (do ((l list (cddr l))
  57.        (k '() (list* (cadr l) (car l) k)))
  58.       ((or (null l) (not (member (car l) keys)))
  59.        (values (nreverse k) l))))
  60.  
  61. (defmacro with-keyword-pairs ((names expression &optional keywords-var)
  62.                   &body forms)
  63.   (let ((temp (member '&rest names)))
  64.     (unless (= (length temp) 2)
  65.       (error "&rest keyword is ~:[missing~;misplaced~]." temp))
  66.     (let ((key-vars (ldiff names temp))
  67.           (key-var (or keywords-var (gensym)))
  68.           (rest-var (cadr temp)))
  69.       (let ((keywords (mapcar #'(lambda (x)
  70.                   (intern (string x) ext:*keyword-package*))
  71.                   key-vars)))
  72.         `(multiple-value-bind (,key-var ,rest-var)
  73.              (parse-keyword-pairs ,expression ',keywords)
  74.            (let ,(mapcar #'(lambda (var keyword)
  75.                  `(,var (getf ,key-var ,keyword)))
  76.              key-vars keywords)
  77.          ,@forms))))))
  78.  
  79. ) ;eval-when
  80.  
  81.  
  82.  
  83. ;;;; Restarts.
  84.  
  85. (defvar *restart-clusters* '())
  86.  
  87. (defun compute-restarts ()
  88.   "Return a list of all the currently active restarts ordered from most
  89.    recently established to less recently established."
  90.   (copy-list (apply #'append *restart-clusters*)))
  91.  
  92. (defun restart-print (restart stream depth)
  93.   (declare (ignore depth))
  94.   (if *print-escape*
  95.       (format stream "#<~S.~X>"
  96.           (type-of restart) (system:%primitive lisp::make-fixnum restart))
  97.       (restart-report restart stream)))
  98.  
  99. (defstruct (restart (:print-function restart-print))
  100.   name
  101.   function
  102.   report-function
  103.   interactive-function)
  104.  
  105. (setf (documentation 'restart-name 'function)
  106.       "Returns the name of the given restart object.")
  107.  
  108. (defun restart-report (restart stream)
  109.   (funcall (or (restart-report-function restart)
  110.                (let ((name (restart-name restart)))
  111.          #'(lambda (stream)
  112.              (if name (format stream "~S" name)
  113.                   (format stream "~S" restart)))))
  114.            stream))
  115.  
  116. (defmacro restart-bind (bindings &body forms)
  117.   "Executes forms in a dynamic context where the given restart bindings are
  118.    in effect.  Users probably want to use RESTART-CASE.  When clauses contain
  119.    the same restart name, FIND-RESTART will find the first such clause."
  120.   `(let ((*restart-clusters*
  121.       (cons (list
  122.          ,@(mapcar #'(lambda (binding)
  123.                    (unless (or (car binding)
  124.                        (member :report-function
  125.                            binding :test #'eq))
  126.                  (warn "Unnamed restart does not have a ~
  127.                     report function -- ~S"
  128.                        binding))
  129.                    `(make-restart
  130.                  :name ',(car binding)
  131.                  :function ,(cadr binding)
  132.                  ,@(cddr binding)))
  133.                    bindings))
  134.         *restart-clusters*)))
  135.      ,@forms))
  136.  
  137. (defun find-restart (name)
  138.   "Returns the first restart named name.  If name is a restart, it is returned
  139.    if it is currently active.  If no such restart is found, nil is returned.
  140.    It is an error to supply nil as a name."
  141.   (dolist (restart-cluster *restart-clusters*)
  142.     (dolist (restart restart-cluster)
  143.       (when (or (eq restart name) (eq (restart-name restart) name))
  144.     (return-from find-restart restart)))))
  145.   
  146.  
  147. (defun invoke-restart (restart &rest values)
  148.   "Calls the function associated with the given restart, passing any given
  149.    arguments.  If the argument restart is not a restart or a currently active
  150.    non-nil restart name, then a control-error is signalled."
  151.   (let ((real-restart (find-restart restart)))
  152.     (unless real-restart
  153.       (error 'control-error
  154.          :format-string "Restart ~S is not active."
  155.          :format-arguments (list restart)))
  156.     (apply (restart-function real-restart) values)))
  157.  
  158. (defun invoke-restart-interactively (restart)
  159.   "Calls the function associated with the given restart, prompting for any
  160.    necessary arguments.  If the argument restart is not a restart or a
  161.    currently active non-nil restart name, then a control-error is signalled."
  162.   (let ((real-restart (find-restart restart)))
  163.     (unless real-restart
  164.       (error 'control-error
  165.          :format-string "Restart ~S is not active."
  166.          :format-arguments (list restart)))
  167.     (apply (restart-function real-restart)
  168.        (let ((interactive-function
  169.           (restart-interactive-function real-restart)))
  170.          (if interactive-function
  171.          (funcall interactive-function)
  172.          '())))))
  173.  
  174.  
  175. (defmacro restart-case (expression &body clauses)
  176.   "(RESTART-CASE form
  177.    {(case-name arg-list {keyword value}* body)}*)
  178.    The form is evaluated in a dynamic context where the clauses have special
  179.    meanings as points to which control may be transferred (see INVOKE-RESTART).
  180.    When clauses contain the same case-name, FIND-RESTART will find the first
  181.    such clause."
  182.   (flet ((transform-keywords (&key report interactive)
  183.        (let ((result '()))
  184.          (when report
  185.            (setq result (list* (if (stringp report)
  186.                        `#'(lambda (stream)
  187.                         (write-string ,report stream))
  188.                        `#',report)
  189.                    :report-function
  190.                    result)))
  191.          (when interactive
  192.            (setq result (list* `#',interactive
  193.                    :interactive-function
  194.                    result)))
  195.          (nreverse result))))
  196.     (let ((temp-var (gensym))
  197.       (outer-tag (gensym))
  198.       (inner-tag (gensym))
  199.       (tag-var (gensym))
  200.       (data
  201.         (mapcar #'(lambda (clause)
  202.             (with-keyword-pairs ((report interactive &rest forms)
  203.                          (cddr clause))
  204.               (list (car clause)               ;name=0
  205.                 (gensym)               ;tag=1
  206.                 (transform-keywords :report report ;keywords=2
  207.                             :interactive interactive)
  208.                 (cadr clause)               ;bvl=3
  209.                 forms)))               ;body=4
  210.             clauses)))
  211.       `(let ((,outer-tag (cons nil nil))
  212.          (,inner-tag (cons nil nil))
  213.          ,temp-var ,tag-var)
  214.      (catch ,outer-tag
  215.        (catch ,inner-tag
  216.          (throw ,outer-tag
  217.             (restart-bind
  218.             ,(mapcar #'(lambda (datum)
  219.                      (let ((name (nth 0 datum))
  220.                        (tag  (nth 1 datum))
  221.                        (keys (nth 2 datum)))
  222.                        `(,name #'(lambda (&rest temp)
  223.                            (setf ,temp-var temp)
  224.                            (setf ,tag-var ',tag)
  225.                            (throw ,inner-tag nil))
  226.                            ,@keys)))
  227.                  data)
  228.               ,expression)))
  229.        (case ,tag-var
  230.          ,@(mapcar #'(lambda (datum)
  231.                (let ((tag  (nth 1 datum))
  232.                  (bvl  (nth 3 datum))
  233.                  (body (nth 4 datum)))
  234.                  `(,tag
  235.                    (apply #'(lambda ,bvl ,@body) ,temp-var))))
  236.                data)))))))
  237. #|
  238. This macro doesn't work in our system due to lossage in closing over tags.
  239. The previous version is uglier, but it sets up unique run-time tags.
  240.  
  241. (defmacro restart-case (expression &body clauses)
  242.   "(RESTART-CASE form
  243.    {(case-name arg-list {keyword value}* body)}*)
  244.    The form is evaluated in a dynamic context where the clauses have special
  245.    meanings as points to which control may be transferred (see INVOKE-RESTART).
  246.    When clauses contain the same case-name, FIND-RESTART will find the first
  247.    such clause."
  248.   (flet ((transform-keywords (&key report interactive)
  249.        (let ((result '()))
  250.          (when report
  251.            (setq result (list* (if (stringp report)
  252.                        `#'(lambda (stream)
  253.                         (write-string ,report stream))
  254.                        `#',report)
  255.                    :report-function
  256.                    result)))
  257.          (when interactive
  258.            (setq result (list* `#',interactive
  259.                    :interactive-function
  260.                    result)))
  261.          (nreverse result))))
  262.     (let ((block-tag (gensym))
  263.       (temp-var  (gensym))
  264.       (data
  265.         (mapcar #'(lambda (clause)
  266.             (with-keyword-pairs ((report interactive &rest forms)
  267.                          (cddr clause))
  268.               (list (car clause)               ;name=0
  269.                 (gensym)               ;tag=1
  270.                 (transform-keywords :report report ;keywords=2
  271.                             :interactive interactive)
  272.                 (cadr clause)               ;bvl=3
  273.                 forms)))               ;body=4
  274.             clauses)))
  275.       `(block ,block-tag
  276.      (let ((,temp-var nil))
  277.        (tagbody
  278.          (restart-bind
  279.            ,(mapcar #'(lambda (datum)
  280.                 (let ((name (nth 0 datum))
  281.                   (tag  (nth 1 datum))
  282.                   (keys (nth 2 datum)))
  283.                   `(,name #'(lambda (&rest temp)
  284.                       (setq ,temp-var temp)
  285.                       (go ,tag))
  286.                 ,@keys)))
  287.             data)
  288.            (return-from ,block-tag ,expression))
  289.          ,@(mapcan #'(lambda (datum)
  290.                (let ((tag  (nth 1 datum))
  291.                  (bvl  (nth 3 datum))
  292.                  (body (nth 4 datum)))
  293.                  (list tag
  294.                    `(return-from ,block-tag
  295.                       (apply #'(lambda ,bvl ,@body)
  296.                          ,temp-var)))))
  297.                data)))))))
  298. |#
  299.  
  300. (defmacro with-simple-restart ((restart-name format-string
  301.                          &rest format-arguments)
  302.                    &body forms)
  303.   "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
  304.    body)
  305.    If restart-name is not invoked, then all values returned by forms are
  306.    returned.  If control is transferred to this restart, it immediately
  307.    returns the values nil and t."
  308.   `(restart-case (progn ,@forms)
  309.      (,restart-name ()
  310.         :report (lambda (stream)
  311.           (format stream ,format-string ,@format-arguments))
  312.       (values nil t))))
  313.  
  314.  
  315.  
  316. ;;;; Conditions.
  317.  
  318. (defun condition-print (condition stream depth)
  319.   (declare (ignore depth))
  320.   (if *print-escape*
  321.       (print-unreadable-object (condition stream :identity t)
  322.     (prin1 (type-of condition) stream))
  323.       (handler-case
  324.       (condition-report condition stream)
  325.     (error () (format stream "...~2%; Error reporting condition: ~S.~%"
  326.               condition)))))
  327.  
  328. (eval-when (eval compile load)
  329.  
  330. (defmacro parent-type     (condition-type) `(get ,condition-type 'parent-type))
  331. (defmacro slots           (condition-type) `(get ,condition-type 'slots))
  332. (defmacro conc-name       (condition-type) `(get ,condition-type 'conc-name))
  333. (defmacro report-function (condition-type)
  334.   `(get ,condition-type 'report-function))
  335. (defmacro make-function   (condition-type) `(get ,condition-type 'make-function))
  336.  
  337. ) ;eval-when
  338.  
  339. (defun condition-report (condition stream)
  340.   (do ((type (type-of condition) (parent-type type)))
  341.       ((not type)
  342.        (format stream "The condition ~A occurred." (type-of condition)))
  343.     (let ((reporter (report-function type)))
  344.       (when reporter
  345.         (funcall reporter condition stream)
  346.         (return nil)))))
  347.  
  348. (setf (make-function   'condition) '|constructor for condition|)
  349.  
  350. (defun make-condition (type &rest slot-initializations)
  351.   "Makes a condition of type type using slot-initializations as initial values
  352.    for the slots."
  353.   (let ((fn (make-function type)))
  354.     (cond ((not fn) (error 'simple-type-error
  355.                :datum type
  356.                :expected-type '(satisfies make-function)
  357.                :format-string "Not a condition type: ~S"
  358.                :format-arguments (list type)))
  359.           (t (apply fn slot-initializations)))))
  360.  
  361.  
  362. ;;; Some utilities used at macro expansion time.
  363. ;;;
  364. (eval-when (eval compile load)
  365.  
  366. (defmacro resolve-function (function expression resolver)
  367.   `(cond ((and ,function ,expression)
  368.           (cerror "Use only the :~A information."
  369.                   "Only one of :~A and :~A is allowed."
  370.                   ',function ',expression))
  371.          (,expression (setq ,function ,resolver))))
  372.          
  373. (defun parse-new-and-used-slots (slots parent-type)
  374.   (let ((new '()) (used '()))
  375.     (dolist (slot slots)
  376.       (if (slot-used-p (car slot) parent-type)
  377.           (push slot used)
  378.           (push slot new)))
  379.     (values new used)))
  380.  
  381. (defun slot-used-p (slot-name type)
  382.   (cond ((eq type 'condition) nil)
  383.         ((not type) (error "The type ~S does not inherit from condition." type))
  384.         ((assoc slot-name (slots type)))
  385.         (t (slot-used-p slot-name (parent-type type)))))
  386.  
  387. ) ;eval-when
  388.  
  389. (defmacro define-condition (name (parent-type) &optional slot-specs
  390.                  &rest options)
  391.   "(DEFINE-CONDITION name (parent-type)
  392.       ( {slot-name | (slot-name {slot-option}*)}*)
  393.       options)"
  394.   (let ((constructor (let ((*package* (find-package "CONDITIONS")))
  395.                ;; Bind for the INTERN and the FORMAT.
  396.                (intern (format nil "Constructor for ~S" name)))))
  397.     (let ((slots (mapcar #'(lambda (slot-spec)
  398.                  (cond
  399.                   ((atom slot-spec)
  400.                    (list slot-spec))
  401.                   ((atom (cdr slot-spec))
  402.                    slot-spec)
  403.                   ((atom (cddr slot-spec))
  404.                    (warn "Old style slot specifier: ~S" slot-spec)
  405.                    slot-spec)
  406.                   (t
  407.                    (destructuring-bind
  408.                    (name &key (type nil typep) initform
  409.                      &allow-other-keys)
  410.                    slot-spec
  411.                  `(,name ,initform
  412.                      ,@(when typep `(:type ,type)))))))
  413.              slot-specs)))
  414.       (multiple-value-bind (new-slots used-slots)
  415.           (parse-new-and-used-slots slots parent-type)
  416.     (let ((conc-name-p     nil)
  417.           (conc-name       nil)
  418.           (report-function nil)
  419.           (documentation   nil))
  420.       (do ((o options (cdr o)))
  421.           ((null o))
  422.         (let ((option (car o)))
  423.           (case (car option) ;should be ecase
  424.         (:conc-name
  425.          (setq conc-name-p t)
  426.          (setq conc-name (cadr option)))
  427.         (:report
  428.          (setq report-function
  429.                (if (stringp (cadr option))
  430.                `(lambda (stream)
  431.                   (write-string ,(cadr option) stream))
  432.                (cadr option))))
  433.         (:documentation (setq documentation (cadr option)))
  434.         (otherwise
  435.          (cerror "Ignore this DEFINE-CONDITION option."
  436.              "Invalid DEFINE-CONDITION option: ~S" option)))))
  437.       (unless conc-name-p
  438.         (setq conc-name
  439.           (intern (concatenate 'simple-string (symbol-name name)
  440.                        "-")
  441.               *package*)))
  442.       ;; The following three forms are compile-time side-effects.  For now,
  443.       ;; they affect the global environment, but with modified abstractions
  444.       ;; for parent-type, slots, and conc-name, the compiler could easily
  445.       ;; make them local.
  446.       (setf (parent-type name) parent-type)
  447.           (setf (slots name)       slots)
  448.           (setf (conc-name name)   conc-name)
  449.           ;; finally, the expansion ...
  450.       `(progn
  451.          (defstruct (,name
  452.              (:constructor ,constructor)
  453.              (:predicate nil)
  454.              (:copier nil)
  455.              (:print-function condition-print)
  456.              (:include ,parent-type ,@used-slots)
  457.              (:conc-name ,conc-name))
  458.            ,@new-slots)
  459.          (setf (documentation ',name 'type) ',documentation)
  460.          (setf (parent-type ',name) ',parent-type)
  461.          (setf (slots ',name) ',slots)
  462.          (setf (conc-name ',name) ',conc-name)
  463.          (setf (report-function ',name)
  464.            ,(if report-function `#',report-function))
  465.          (setf (make-function ',name) ',constructor)
  466.          ',name))))))
  467.  
  468.  
  469.  
  470. ;;;; HANDLER-BIND and SIGNAL.
  471.  
  472. (defvar *handler-clusters* nil)
  473.  
  474. (defmacro handler-bind (bindings &body forms)
  475.   "(HANDLER-BIND ( {(type handler)}* )  body)
  476.    Executes body in a dynamic context where the given handler bindings are
  477.    in effect.  Each handler must take the condition being signalled as an
  478.    argument.  The bindings are searched first to last in the event of a
  479.    signalled condition."
  480.   (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
  481.     (error "Ill-formed handler bindings."))
  482.   `(let ((*handler-clusters*
  483.       (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
  484.                 bindings))
  485.         *handler-clusters*)))
  486.      ,@forms))
  487.  
  488. (defvar *break-on-signals* nil
  489.   "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
  490.    enter the debugger prior to signalling that condition.")
  491.  
  492. (defun signal (datum &rest arguments)
  493.   "Invokes the signal facility on a condition formed from datum and arguments.
  494.    If the condition is not handled, nil is returned.  If
  495.    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
  496.    any signalling is done."
  497.   (let ((condition (coerce-to-condition datum arguments
  498.                     'simple-condition 'signal))
  499.         (*handler-clusters* *handler-clusters*))
  500.     (when (typep condition *break-on-signals*)
  501.       (break "~A~%Break entered because of *break-on-signals*."
  502.          condition))
  503.     (loop
  504.       (unless *handler-clusters* (return))
  505.       (let ((cluster (pop *handler-clusters*)))
  506.     (dolist (handler cluster)
  507.       (when (typep condition (car handler))
  508.         (funcall (cdr handler) condition)))))
  509.     nil))
  510.  
  511. ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
  512. ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
  513. ;;; argument that's directly usable by all the other routines.
  514. ;;;
  515. (defun coerce-to-condition (datum arguments default-type function-name)
  516.   (cond ((typep datum 'condition)
  517.      (if arguments
  518.          (cerror "Ignore the additional arguments."
  519.              'simple-type-error
  520.              :datum arguments
  521.              :expected-type 'null
  522.              :format-string "You may not supply additional arguments ~
  523.                      when giving ~S to ~S."
  524.              :format-arguments (list datum function-name)))
  525.      datum)
  526.         ((symbolp datum) ;Roughly, (subtypep datum 'condition).
  527.          (apply #'make-condition datum arguments))
  528.         ((or (stringp datum) (functionp datum))
  529.      (make-condition default-type
  530.                          :format-string datum
  531.                          :format-arguments arguments))
  532.         (t
  533.          (error 'simple-type-error
  534.         :datum datum
  535.         :expected-type '(or symbol string)
  536.         :format-string "Bad argument to ~S: ~S"
  537.         :format-arguments (list function-name datum)))))
  538.  
  539.  
  540.  
  541. ;;;; ERROR, CERROR, BREAK, WARN.
  542.  
  543. (define-condition serious-condition (condition) ())
  544.  
  545. (define-condition error (serious-condition)
  546.   ((function-name nil)))
  547.  
  548. (defun error (datum &rest arguments)
  549.   "Invokes the signal facility on a condition formed from datum and arguments.
  550.    If the condition is not handled, the debugger is invoked."
  551.   (kernel:infinite-error-protect
  552.     (let ((condition (coerce-to-condition datum arguments
  553.                       'simple-error 'error))
  554.       (debug:*stack-top-hint* debug:*stack-top-hint*))
  555.       (unless (and (error-function-name condition) debug:*stack-top-hint*)
  556.     (multiple-value-bind
  557.         (name frame)
  558.         (kernel:find-caller-name)
  559.       (unless (error-function-name condition)
  560.         (setf (error-function-name condition) name))
  561.       (unless debug:*stack-top-hint*
  562.         (setf debug:*stack-top-hint* frame))))
  563.       (let ((debug:*stack-top-hint* nil))
  564.     (signal condition))
  565.       (invoke-debugger condition))))
  566.  
  567. ;;; CERROR must take care to not use arguments when datum is already a
  568. ;;; condition object.
  569. ;;;
  570. (defun cerror (continue-string datum &rest arguments)
  571.   (kernel:infinite-error-protect
  572.     (with-simple-restart
  573.     (continue "~A" (apply #'format nil continue-string arguments))
  574.       (let ((condition (if (typep datum 'condition)
  575.                datum
  576.                (coerce-to-condition datum arguments
  577.                         'simple-error 'error)))
  578.         (debug:*stack-top-hint* debug:*stack-top-hint*))
  579.     (unless (and (error-function-name condition) debug:*stack-top-hint*)
  580.       (multiple-value-bind
  581.           (name frame)
  582.           (kernel:find-caller-name)
  583.         (unless (error-function-name condition)
  584.           (setf (error-function-name condition) name))
  585.         (unless debug:*stack-top-hint*
  586.           (setf debug:*stack-top-hint* frame))))
  587.     (let ((debug:*stack-top-hint* nil))
  588.       (signal condition))
  589.     (invoke-debugger condition))))
  590.   nil)
  591.  
  592. (defun break (&optional (datum "Break") &rest arguments)
  593.   "Prints a message and invokes the debugger without allowing any possibility
  594.    of condition handling occurring."
  595.   (kernel:infinite-error-protect
  596.     (with-simple-restart (continue "Return from BREAK.")
  597.       (let ((debug:*stack-top-hint*
  598.          (or debug:*stack-top-hint*
  599.          (nth-value 1 (kernel:find-caller-name)))))
  600.     (invoke-debugger
  601.      (coerce-to-condition datum arguments 'simple-condition 'break)))))
  602.   nil)
  603.  
  604. (define-condition warning (condition) ())
  605.  
  606. (defvar *break-on-warnings* ()
  607.   "If non-NIL, then WARN will enter a break loop before returning.")
  608.  
  609. (defun warn (datum &rest arguments)
  610.   "Warns about a situation by signalling a condition formed by datum and
  611.    arguments.  Before signalling, if *break-on-warnings* is set, then BREAK
  612.    is called.  While the condition is being signaled, a muffle-warning restart
  613.    exists that causes WARN to immediately return nil."
  614.   (kernel:infinite-error-protect
  615.     (let ((condition (coerce-to-condition datum arguments
  616.                       'simple-warning 'warn)))
  617.       (check-type condition warning "a warning condition")
  618.       (if *break-on-warnings*
  619.       (break "~A~%Break entered because of *break-on-warnings*."
  620.          condition))
  621.       (restart-case (signal condition)
  622.     (muffle-warning ()
  623.       :report "Skip warning."
  624.       (return-from warn nil)))
  625.       (format *error-output* "~&~@<Warning:  ~3i~:_~A~:>~%" condition)))
  626.   nil)
  627.  
  628.  
  629. ;;;; Condition definitions.
  630.  
  631. ;;; Serious-condition and error are defined on the previous page, so ERROR and
  632. ;;; CERROR can SETF a slot in the error condition object.
  633. ;;;
  634.  
  635.  
  636. (defun simple-condition-printer (condition stream)
  637.   (apply #'format stream (simple-condition-format-string condition)
  638.               (simple-condition-format-arguments condition)))
  639.  
  640. ;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
  641. ;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
  642. ;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
  643. ;;; This seems to create some kind of bogus multiple inheritance that the user
  644. ;;; sees.
  645. ;;;
  646. (define-condition simple-condition (condition)
  647.   (format-string
  648.    (format-arguments '()))
  649.   (:conc-name internal-simple-condition-)
  650.   (:report simple-condition-printer))
  651.  
  652. ;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
  653. ;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
  654. ;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
  655. ;;; This seems to create some kind of bogus multiple inheritance that the user
  656. ;;; sees.
  657. ;;;
  658. (define-condition simple-warning (warning)
  659.   (format-string
  660.    (format-arguments '()))
  661.   (:conc-name internal-simple-warning-)
  662.   (:report simple-condition-printer))
  663.  
  664.  
  665. (defun print-simple-error (condition stream)
  666.   (format stream "~&~@<Error in function ~S:  ~3i~:_~?~:>"
  667.       (internal-simple-error-function-name condition)
  668.       (internal-simple-error-format-string condition)
  669.       (internal-simple-error-format-arguments condition)))
  670.  
  671. ;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
  672. ;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
  673. ;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
  674. ;;; This seems to create some kind of bogus multiple inheritance that the user
  675. ;;; sees.
  676. ;;;
  677. (define-condition simple-error (error)
  678.   (format-string
  679.    (format-arguments '()))
  680.   (:conc-name internal-simple-error-)
  681.   (:report print-simple-error))
  682.  
  683.  
  684. (define-condition storage-condition (serious-condition) ())
  685.  
  686. (define-condition stack-overflow    (storage-condition) ())
  687. (define-condition storage-exhausted (storage-condition) ())
  688.  
  689. (define-condition type-error (error)
  690.   (datum
  691.    expected-type)
  692.   (:report
  693.    (lambda (condition stream)
  694.      (format stream "~@<Type-error in ~S:  ~3i~:_~S is not of type ~S~:>"
  695.          (type-error-function-name condition)
  696.          (type-error-datum condition)
  697.          (type-error-expected-type condition)))))
  698.  
  699. ;;; The simple-type-error type has a conc-name, so
  700. ;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS could
  701. ;;; be written to handle the simple-condition, simple-warning,
  702. ;;; simple-type-error, and simple-error types.  This seems to create some kind
  703. ;;; of bogus multiple inheritance that the user sees.
  704. ;;;
  705. (define-condition simple-type-error (type-error)
  706.   (format-string
  707.    (format-arguments '()))
  708.   (:conc-name internal-simple-type-error-)
  709.   (:report simple-condition-printer))
  710.  
  711. (define-condition case-failure (type-error)
  712.   (name
  713.    possibilities)
  714.   (:report
  715.     (lambda (condition stream)
  716.       (format stream "~@<~S fell through ~S expression.  ~:_Wanted one of ~:S.~:>"
  717.           (type-error-datum condition)
  718.           (case-failure-name condition)
  719.           (case-failure-possibilities condition)))))
  720.  
  721.  
  722. ;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS.
  723. ;;; These exist for the obvious types to seemingly give the impression of
  724. ;;; multiple inheritance.  That is, the last three types inherit from warning,
  725. ;;; type-error, and error while inheriting from simple-condition also.
  726. ;;;
  727. (defun simple-condition-format-string (condition)
  728.   (etypecase condition
  729.     (simple-condition  (internal-simple-condition-format-string  condition))
  730.     (simple-warning    (internal-simple-warning-format-string    condition))
  731.     (simple-type-error (internal-simple-type-error-format-string condition))
  732.     (simple-error      (internal-simple-error-format-string      condition))))
  733. ;;;
  734. (defun simple-condition-format-arguments (condition)
  735.   (etypecase condition
  736.     (simple-condition  (internal-simple-condition-format-arguments  condition))
  737.     (simple-warning    (internal-simple-warning-format-arguments    condition))
  738.     (simple-type-error (internal-simple-type-error-format-arguments condition))
  739.     (simple-error      (internal-simple-error-format-arguments      condition))))
  740.  
  741.  
  742. (define-condition program-error (error) ())
  743.  
  744.  
  745. (defun print-control-error (condition stream)
  746.   (format stream "~&~@<Error in function ~S:  ~3i~:_~?~:>"
  747.       (control-error-function-name condition)
  748.       (control-error-format-string condition)
  749.       (control-error-format-arguments condition)))
  750.  
  751. (define-condition control-error (error)
  752.   (format-string
  753.    (format-arguments nil))
  754.   (:report print-control-error))
  755.  
  756.  
  757. (define-condition stream-error (error) (stream))
  758.  
  759. (define-condition end-of-file (stream-error) ())
  760.  
  761. (define-condition file-error (error) (pathname))
  762.  
  763. (define-condition package-error (error) (package))
  764.  
  765. (define-condition cell-error (error) (name))
  766.  
  767. (define-condition unbound-variable (cell-error) ()
  768.   (:report
  769.    (lambda (condition stream)
  770.      (format stream
  771.          "Error in ~S:  the variable ~S is unbound."
  772.          (cell-error-function-name condition)
  773.          (cell-error-name condition)))))
  774.   
  775. (define-condition undefined-function (cell-error) ()
  776.   (:report
  777.    (lambda (condition stream)
  778.      (format stream
  779.          "Error in ~S:  the function ~S is undefined."
  780.          (cell-error-function-name condition)
  781.          (cell-error-name condition)))))
  782.  
  783. (define-condition arithmetic-error (error) (operation operands)
  784.   (:report (lambda (condition stream)
  785.          (format stream "Arithmetic error ~S signalled."
  786.              (type-of condition))
  787.          (when (arithmetic-error-operation condition)
  788.            (format stream "~%Operation was ~S, operands ~S."
  789.                (arithmetic-error-operation condition)
  790.                (arithmetic-error-operands condition))))))
  791.  
  792. (define-condition division-by-zero         (arithmetic-error) ())
  793. (define-condition floating-point-overflow  (arithmetic-error) ())
  794. (define-condition floating-point-underflow (arithmetic-error) ())
  795. (define-condition floating-point-inexact   (arithmetic-error) ())
  796. (define-condition floating-point-invalid   (arithmetic-error) ())
  797.  
  798.  
  799. ;;;; HANDLER-CASE and IGNORE-ERRORS.
  800.  
  801. (defmacro handler-case (form &rest cases)
  802.   "(HANDLER-CASE form
  803.    { (type ([var]) body) }* )
  804.    Executes form in a context with handlers established for the condition
  805.    types.  A peculiar property allows type to be :no-error.  If such a clause
  806.    occurs, and form returns normally, all its values are passed to this clause
  807.    as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
  808.    var specification."
  809.   (let ((no-error-clause (assoc ':no-error cases)))
  810.     (if no-error-clause
  811.     (let ((normal-return (make-symbol "normal-return"))
  812.           (error-return  (make-symbol "error-return")))
  813.       `(block ,error-return
  814.          (multiple-value-call #'(lambda ,@(cdr no-error-clause))
  815.            (block ,normal-return
  816.          (return-from ,error-return
  817.            (handler-case (return-from ,normal-return ,form)
  818.              ,@(remove no-error-clause cases)))))))
  819.     (let ((var (gensym))
  820.           (outer-tag (gensym))
  821.           (inner-tag (gensym))
  822.           (tag-var (gensym))
  823.           (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
  824.                        cases)))
  825.       `(let ((,outer-tag (cons nil nil))
  826.          (,inner-tag (cons nil nil))
  827.          ,var ,tag-var)
  828.          ,var            ;ignoreable
  829.          (catch ,outer-tag
  830.            (catch ,inner-tag
  831.          (throw ,outer-tag
  832.             (handler-bind
  833.                 ,(mapcar #'(lambda (annotated-case)
  834.                      `(,(cadr annotated-case)
  835.                        #'(lambda (temp)
  836.                            ,(if (caddr annotated-case)
  837.                             `(setq ,var temp)
  838.                             '(declare (ignore temp)))
  839.                            (setf ,tag-var
  840.                              ',(car annotated-case))
  841.                            (throw ,inner-tag nil))))
  842.                      annotated-cases)
  843.               ,form)))
  844.            (case ,tag-var
  845.          ,@(mapcar #'(lambda (annotated-case)
  846.                    (let ((body (cdddr annotated-case))
  847.                      (varp (caddr annotated-case)))
  848.                  `(,(car annotated-case)
  849.                    ,@(if varp
  850.                      `((let ((,(car varp) ,var))
  851.                          ,@body))
  852.                      body))))
  853.                annotated-cases))))))))
  854. #|
  855. This macro doesn't work in our system due to lossage in closing over tags.
  856. The previous version sets up unique run-time tags.
  857.  
  858. (defmacro handler-case (form &rest cases)
  859.   "(HANDLER-CASE form
  860.    { (type ([var]) body) }* )
  861.    Executes form in a context with handlers established for the condition
  862.    types.  A peculiar property allows type to be :no-error.  If such a clause
  863.    occurs, and form returns normally, all its values are passed to this clause
  864.    as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
  865.    var specification."
  866.   (let ((no-error-clause (assoc ':no-error cases)))
  867.     (if no-error-clause
  868.     (let ((normal-return (make-symbol "normal-return"))
  869.           (error-return  (make-symbol "error-return")))
  870.       `(block ,error-return
  871.          (multiple-value-call #'(lambda ,@(cdr no-error-clause))
  872.            (block ,normal-return
  873.          (return-from ,error-return
  874.            (handler-case (return-from ,normal-return ,form)
  875.              ,@(remove no-error-clause cases)))))))
  876.     (let ((tag (gensym))
  877.           (var (gensym))
  878.           (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
  879.                        cases)))
  880.       `(block ,tag
  881.          (let ((,var nil))
  882.            ,var                ;ignorable
  883.            (tagbody
  884.          (handler-bind
  885.           ,(mapcar #'(lambda (annotated-case)
  886.                    (list (cadr annotated-case)
  887.                      `#'(lambda (temp)
  888.                       ,(if (caddr annotated-case)
  889.                            `(setq ,var temp)
  890.                            '(declare (ignore temp)))
  891.                       (go ,(car annotated-case)))))
  892.                annotated-cases)
  893.                    (return-from ,tag ,form))
  894.          ,@(mapcan
  895.             #'(lambda (annotated-case)
  896.             (list (car annotated-case)
  897.                   (let ((body (cdddr annotated-case)))
  898.                 `(return-from
  899.                   ,tag
  900.                   ,(cond ((caddr annotated-case)
  901.                       `(let ((,(caaddr annotated-case)
  902.                           ,var))
  903.                          ,@body))
  904.                      ((not (cdr body))
  905.                       (car body))
  906.                      (t
  907.                       `(progn ,@body)))))))
  908.                annotated-cases))))))))
  909. |#
  910.  
  911. (defmacro ignore-errors (&rest forms)
  912.   "Executes forms after establishing a handler for all error conditions that
  913.    returns from this form nil and the condition signalled."
  914.   `(handler-case (progn ,@forms)
  915.      (error (condition) (values nil condition))))
  916.  
  917.  
  918.  
  919. ;;;; Restart definitions.
  920.  
  921. (define-condition abort-failure (control-error) ()
  922.   (:report
  923.    "Found an \"abort\" restart that failed to transfer control dynamically."))
  924.  
  925. ;;; ABORT signals an error in case there was a restart named abort that did
  926. ;;; not tranfer control dynamically.  This could happen with RESTART-BIND.
  927. ;;;
  928. (defun abort ()
  929.   "Transfers control to a restart named abort, signalling a control-error if
  930.    none exists."
  931.   (invoke-restart 'abort)
  932.   (error 'abort-failure))
  933.  
  934.  
  935. (defun muffle-warning ()
  936.   "Transfers control to a restart named muffle-warning, signalling a
  937.    control-error if none exists."
  938.   (invoke-restart 'muffle-warning))
  939.  
  940.  
  941. ;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep
  942. ;;; INVOKE-RESTART from signalling a control-error condition.
  943. ;;;
  944. (defmacro define-nil-returning-restart (name args doc)
  945.   `(defun ,name ,args
  946.      ,doc
  947.      (if (find-restart ',name) (invoke-restart ',name ,@args))))
  948.  
  949. (define-nil-returning-restart continue ()
  950.   "Transfer control to a restart named continue, returning nil if none exists.")
  951.  
  952. (define-nil-returning-restart store-value (value)
  953.   "Transfer control and value to a restart named store-value, returning nil if
  954.    none exists.")
  955.  
  956. (define-nil-returning-restart use-value (value)
  957.   "Transfer control and value to a restart named use-value, returning nil if
  958.    none exists.")
  959.